home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 11 / Cream of the Crop 11-2.iso / extra_2 / imagelib.zip / TMULTIP.PAS < prev   
Pascal/Delphi Source File  |  1995-09-30  |  39KB  |  1,304 lines
  1. {$X+,I+,R-}   {<<<<  This is a switch. Don't delete it}
  2.  
  3. {Copyright 1995 by
  4.  Kevin Adams, 74742,1444
  5.  Jan Dekkers, 72130,353
  6.  
  7. With thanks to Andy Satori for his Visual Component advise. Andy can
  8. be reached on CIS [71221,2010] or http://TheClassifieds.Com
  9.  
  10. No part of this Unit may be copied in any way. However, you may derive
  11. other objects from TPMultiImage.
  12.  
  13. Part of Imagelib VCL/DLL Library. Uses ImageLib 3.0 Changed the callback
  14. to a function instead of a procedure to let the user cancel out.
  15.  
  16. Bug fixes:
  17.  
  18. Changed callback in version 2.21 to a function with cdecl using the
  19. C calling convention.
  20.  
  21. Version 2.2.2 Added property ImageLibPalette which If set to True will
  22. use the ImageLib Way to paint. If False it will paint the Delphi way.
  23. This is a fix of a Stretchdraw Delphi bug which doesn't paint correctly
  24. 256 color palettes on 256 color Video cards}
  25.  
  26.  
  27. unit TMultiP; {To be used with version 3.0 of imagelib vcl}
  28.  
  29. interface
  30.  
  31. uses Setcr30, Setsr30,
  32.      SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms,
  33.      Controls, Extctrls, StdCtrls, DLL30, Menus, Mask, Buttons, Printers;
  34.  
  35.  
  36. type
  37.   TPMultiImage = class(TCustomControl)
  38.   private
  39.     FPicture            : TPicture;
  40.     FAutoSize           : Boolean;
  41.     FBorderStyle        : TBorderStyle;
  42.     FStretch            : Boolean;
  43.     FCenter             : Boolean;
  44.     FReserved           : Byte;
  45.     FFilename           : TFilename;
  46.     FDither             : Boolean;
  47.     FReadResolution     : TResolution;
  48.     FWriteResolution    : TResolution;
  49.     FInterlaced         : Boolean;
  50.     FSaveQuality        : Byte;
  51.     FSaveSmooth         : Byte;
  52.     FSaveFilename       : TFilename;
  53.     FImageLibPalette    : Boolean;
  54.     Temps               : TFilename;
  55.     BitMsg              : TBitmap;
  56.     SMessageLeft        : Integer;
  57.     SMessageRight       : Integer;
  58.     SMessageTop         : Integer;
  59.     ScreenWd            : Integer;
  60.     ScreenHt            : Integer;
  61.     BitWidth            : Integer;
  62.     DelayCounter        : Longint;
  63.     OldColor            : TColor;
  64.     SMessageBottom      : Integer;
  65.     BitHeight           : Integer;
  66.     Creditcounter       : Integer;
  67.     procedure PictureChanged(Sender: TObject);
  68.     procedure SetAutoSize(Value: Boolean);
  69.     procedure SetCenter(Value: Boolean);
  70.     procedure SetPicture(Value: TPicture);
  71.     procedure SetStretch(Value: Boolean);
  72.     procedure SetBorderStyle(Value: TBorderStyle);
  73.     procedure WMCut(var Message: TMessage); message WM_CUT;
  74.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  75.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  76.   protected
  77.     function GetPalette: HPALETTE; override;
  78.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  79.     procedure KeyPress(var Key: Char); override;
  80.     procedure CreateParams(var Params: TCreateParams); override;
  81.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  82.     procedure PrintBitmap(X, Y, pWidth, pHeight: Integer);
  83.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  84.     procedure LoadMessageFromFile(MessageName : TFilename);
  85.     Function Delay(Ms : Integer) : boolean;
  86.     Procedure MoveCredMsg(Var WinMsg : TMessage); message WM_CTrigger;
  87.     procedure LoadCreditMessageFromFile(MessageName : TFilename);
  88.   public
  89.     BFiletype           :  String;
  90.     Bwidth              :  Integer;
  91.     BHeight             :  Integer;
  92.     Bbitspixel          :  Integer;
  93.     Bplanes             :  Integer;
  94.     Bnumcolors          :  Integer;
  95.     BSize               :  Longint;
  96.     Bcompression        :  String;
  97.     {Messages}
  98.     MessageRunning      :  Boolean;
  99.     MsgText             :  String;
  100.     MsgFont             :  TFont;
  101.     MsgBkGrnd           :  TColor;
  102.     MsgSpeed            :  Integer;
  103.     {credit message}
  104.     CreditBoxList       :  TStringList;
  105.     CMessageRunning     :  Boolean;
  106.     ResProgName         :  String;
  107.     constructor Create(AOwner: TComponent); override;
  108.     destructor Destroy; override;
  109.     procedure CopyToClipboard;
  110.     procedure CutToClipboard;
  111.     procedure PasteFromClipboard;
  112.     function GetMultiBitmap : String;
  113.     Procedure WriteMultiName(Name : String);
  114.     procedure Paint; override;
  115.     procedure PaintTheDelpiWay;
  116.     function GetSmooth : Byte;
  117.     procedure SetSmooth(smooth : Byte);
  118.     function GetQuality : Byte;
  119.     procedure SetQuality(Quality : Byte);
  120.     procedure SetReadRes(Res : TResolution);
  121.     procedure SetWriteRes(Res : TResolution);
  122.     function GetSaveFilename : TFilename;
  123.     procedure SetSaveFilename(fn : TFilename);
  124.     procedure SaveAsJpg(FN : TFilename);
  125.     procedure SaveAsBMP(FN : TFilename);
  126.     procedure SaveAsPNG(FN : TFilename);
  127.     procedure SaveAsGIF(FN : TFilename);
  128.     procedure SaveAsPCX(FN : TFilename);
  129.     function GetInfoAndType(Filename : TFilename) : Boolean;
  130.     {function LoadBMPFromResource(ProgName, BMPResName : String) : Boolean;}
  131.     {scrolling message}
  132.     Procedure Trigger;
  133.     procedure CreateMessage(MessagePath : String; AutoLoad : Boolean);
  134.     procedure SaveCurrentMessage(MessageName : TFilename);
  135.     procedure NewMessage;
  136.     Procedure FreeMsg;
  137.     {credit message}
  138.     procedure CreateCreditMessage(MessagePath : String; AutoLoad : Boolean);
  139.     procedure SaveCurrentCreditMessage(MessageName : TFilename);
  140.     procedure NewCreditMessage;
  141.     {printing}
  142.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  143.   published
  144.     property Align;
  145.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  146.     property Center: Boolean read FCenter write SetCenter default False;
  147.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
  148.     property Color;
  149.     property DragCursor;
  150.     property DragMode;
  151.     property DefSaveFilename : TFilename read GetSaveFilename write SetSaveFilename;
  152.     property Enabled;
  153.     property Picture: TPicture read FPicture write SetPicture;
  154.     property ImageName  : String read GetMultiBitmap write WriteMultiName;
  155.     property ImageLibPalette : Boolean read FImageLibPalette write FImageLibPalette default True;
  156.     property ImageDither : Boolean read FDither write FDither;
  157.     property ImageReadRes : TResolution read FReadResolution write SetReadRes;
  158.     property ImageWriteRes : TResolution read FWriteResolution write SetWriteRes;
  159.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  160.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  161.     property OnClick;
  162.     property OnDblClick;
  163.     property OnDragDrop;
  164.     property OnDragOver;
  165.     property OnEndDrag;
  166.     property OnKeyDown;
  167.     property OnKeyPress;
  168.     property OnKeyUp;
  169.     property OnMouseDown;
  170.     property OnMouseMove;
  171.     property OnMouseUp;
  172.     property ParentColor default False;
  173.     property ParentFont;
  174.     property ParentShowHint;
  175.     property PopupMenu;
  176.     property PNGInterLaced : Boolean read FInterlaced write FInterlaced default False;
  177.     property ShowHint;
  178.     property Stretch: Boolean read FStretch write SetStretch default False;
  179.     property TabOrder;
  180.     property TabStop default True;
  181.     property Visible;
  182.   end;
  183.  
  184.  
  185. var
  186.  TPMultiImageCallBack   : TCallBackFunction;
  187.  
  188.  {------------------------------------------------------------------------}
  189.  
  190. implementation
  191.  
  192.   uses   Consts, Clipbrd, Dialogs, ToolHelp;
  193.  
  194. {------------------------------------------------------------------------
  195.  TPMultiImage.
  196. ------------------------------------------------------------------------}
  197.  
  198. constructor TPMultiImage.Create(AOwner: TComponent);
  199. begin
  200.   inherited Create(AOwner);
  201.   FPicture := TPicture.Create;
  202.   FPicture.OnChange := PictureChanged;
  203.   FFilename:='';
  204.   FDither:=True;
  205.   FReadResolution := Color256;
  206.   FWriteResolution := Color256;
  207.   FSaveQuality:=25;
  208.   FSaveSmooth:=0;
  209.   FBorderStyle := bsNone;
  210.   FImageLibPalette:=True;
  211.   FInterlaced:=False;
  212.   Picture.Graphic := nil;
  213.   Height := 105;
  214.   Width := 105;
  215.   MsgFont:=TFont.Create;
  216.   BitMsg := TBitmap.Create;
  217.   MessageRunning:=False;
  218.   CMessageRunning:=False;
  219.   SetupMsg30:=Nil;
  220.   SetupCredMsg30:=Nil;
  221.   DelayCounter:=0;
  222.   Color:=clBtnFace;
  223.   CreditBoxList:=TStringList.Create;
  224.   Creditcounter:=0;
  225.   ResProgName:='';
  226.  end;
  227. {------------------------------------------------------------------------}
  228.  
  229. destructor TPMultiImage.Destroy;
  230. begin
  231.   FPicture.Free;
  232.   MsgFont.Free;
  233.   BitMsg.Free;
  234.   CreditBoxList.Free;
  235.   inherited Destroy;
  236. end;
  237. {------------------------------------------------------------------------}
  238.  
  239. function TPMultiImage.GetPalette: HPALETTE;
  240. begin
  241.   Result := 0;
  242.   If ImageLibPalette then Exit;
  243.   If FPicture.Graphic is TBitmap then
  244.     Result := TBitmap(FPicture.Graphic).Palette;
  245. end;
  246. {------------------------------------------------------------------------}
  247.  
  248. procedure TPMultiImage.SetBorderStyle(Value: TBorderStyle);
  249. begin
  250.   If FBorderStyle <> Value then
  251.   begin
  252.     FBorderStyle := Value;
  253.     RecreateWnd;
  254.   end;
  255. end;
  256. {------------------------------------------------------------------------}
  257.  
  258. procedure TPMultiImage.CreateParams(var Params: TCreateParams);
  259. begin
  260.   inherited CreateParams(Params);
  261.   If FBorderStyle = bsSingle then
  262.     Params.Style := Params.Style or WS_BORDER;
  263. end;
  264. {------------------------------------------------------------------------}
  265.  
  266. procedure TPMultiImage.Paint;
  267. var
  268.   W, H: Integer;
  269.   R: TRect;
  270.   S: String[63];
  271.   OldBitmap : HBitmap;
  272.   MemDC : HDC;
  273.   hOldPal : HPalette;
  274. begin
  275.  
  276.   If csDesigning in ComponentState then
  277.     with Canvas do
  278.     begin
  279.       Pen.Style := psDash;
  280.       Brush.Style := bsClear;
  281.       Rectangle(0, 0, Width, Height);
  282.     end;
  283.  
  284.   If (BFileType = 'ICO') or (BFileType = 'WMF') or (not ImageLibPalette) then begin
  285.       PaintTheDelpiWay;
  286.       Exit;
  287.   end;
  288.  
  289.   with Canvas do begin
  290.     Brush.Style := bsSolid;
  291.     Brush.Color := Color;
  292.  
  293.     If Picture.Graphic <> nil then
  294.     If Stretch then begin
  295.  
  296.       hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  297.       RealizePalette(Canvas.handle);
  298.       MemDC := CreateCompatibleDC(Canvas.handle);
  299.       OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  300.       SetStretchBltMode(canvas.handle,STRETCH_DELETESCANS);
  301.       StretchBlt(Canvas.handle,
  302.                  ClientRect.Left,
  303.                  ClientRect.Top,
  304.                  ClientRect.Right,
  305.                  ClientRect.Bottom,
  306.                  MemDC,
  307.                  ClientRect.Left,
  308.                  ClientRect.Top,
  309.                  Picture.Bitmap.Width,
  310.                  Picture.Bitmap.Height,
  311.                  SrcCopy);
  312.  
  313.       SelectObject(MemDC,OldBitmap);
  314.       DeleteDC(MemDC);
  315.       SelectPalette(Canvas.handle,hOldPal,False);
  316.  
  317.      end else begin
  318.  
  319.       SetRect(R, 0, 0, Picture.Width, Picture.Height);
  320.       If Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  321.           (ClientHeight - Picture.Height) div 2);
  322.  
  323.       hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  324.       RealizePalette(Canvas.handle);
  325.       MemDC := CreateCompatibleDC(Canvas.handle);
  326.       OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  327.  
  328.       BitBlt(Canvas.handle,
  329.              R.Left,
  330.              R.Top,
  331.              Picture.Bitmap.Width,
  332.              Picture.Bitmap.Height,
  333.              MemDC,
  334.              0,
  335.              0,
  336.              srcCopy);
  337.  
  338.       SelectObject(MemDC,OldBitmap);
  339.       DeleteDC(MemDC);
  340.       SelectPalette(Canvas.handle,hOldPal,False);
  341.     end;
  342.  
  343.     If (GetParentForm(Self).ActiveControl = Self) and
  344.       not (csDesigning in ComponentState) then
  345.     begin
  346.       Brush.Color := clWindowFrame;
  347.       FrameRect(ClientRect);
  348.     end;
  349.  
  350.   end;
  351.   If (MessageRunning) and (Picture = nil) then FreeMsg;
  352.   If (CMessageRunning) and (Picture = nil) then FreeMsg;
  353. end;
  354. {------------------------------------------------------------------------}
  355.  
  356. procedure TPMultiImage.PaintTheDelpiWay;
  357. var
  358.   Dest : TRect;
  359. begin
  360.   If Stretch then
  361.     Dest := ClientRect
  362.   else If Center then
  363.     Dest := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
  364.       Picture.Width, Picture.Height)
  365.   else
  366.     Dest := Rect(0, 0, Picture.Width, Picture.Height);
  367.     Canvas.StretchDraw(Dest, Picture.Graphic);
  368. end;
  369. {------------------------------------------------------------------------}
  370.  
  371.  
  372. procedure TPMultiImage.SetAutoSize(Value: Boolean);
  373. begin
  374.   FAutoSize := Value;
  375.   PictureChanged(Self);
  376. end;
  377. {------------------------------------------------------------------------}
  378.  
  379. procedure TPMultiImage.SetCenter(Value: Boolean);
  380. begin
  381.   If FCenter <> Value then
  382.   begin
  383.     FCenter := Value;
  384.     Invalidate;
  385.   end;
  386. end;
  387. {------------------------------------------------------------------------}
  388.  
  389. procedure TPMultiImage.SetPicture(Value: TPicture);
  390. begin
  391.   FPicture.Assign(Value);
  392. end;
  393. {------------------------------------------------------------------------}
  394.  
  395. procedure TPMultiImage.SetStretch(Value: Boolean);
  396. begin
  397.   If FStretch <> Value then
  398.   begin
  399.     FStretch := Value;
  400.     Invalidate;
  401.   end;
  402. end;
  403. {------------------------------------------------------------------------}
  404.  
  405. procedure TPMultiImage.PictureChanged(Sender: TObject);
  406. begin
  407.   If AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
  408.     SetBounds(Left, Top, Picture.Width, Picture.Height);
  409.   If (Picture.Graphic is TBitmap) and (Picture.Width = Width) and
  410.     (Picture.Height = Height) then
  411.     ControlStyle := ControlStyle + [csOpaque] else
  412.     ControlStyle := ControlStyle - [csOpaque];
  413.   Invalidate;
  414. end;
  415. {------------------------------------------------------------------------}
  416.  
  417. procedure TPMultiImage.SetReadRes(Res : TResolution);
  418. begin
  419.   FReadResolution := Res;
  420. end;
  421. {------------------------------------------------------------------------}
  422.  
  423. procedure TPMultiImage.SetWriteRes(Res : TResolution);
  424. begin
  425.   FWriteResolution := Res;
  426. end;
  427. {------------------------------------------------------------------------}
  428.  
  429. Procedure TPMultiImage.WriteMultiName(Name : String);
  430. begin
  431.   FFilename:=Name;
  432.   GetMultiBitmap;
  433. end;
  434. {------------------------------------------------------------------------}
  435.  
  436.  
  437. function TPMultiImage.GetMultiBitmap :  String;
  438. var    Bitmap     : TBitmap;
  439.        Pextension : String[4];
  440.        OnExcept   : Boolean;
  441.        F          : file of Byte;
  442.        Dith       : Integer;
  443.        ReadRes    : Integer;
  444.  
  445. label  BreakIt;
  446.  
  447. begin
  448.   OnExcept:=False;
  449.  
  450.   Pextension:=UpperCase(ExtractFileExt(FFilename));
  451.  
  452.   If Pextension <>  '.RES' then
  453.   If not FileExists(FFilename) then begin
  454.      Picture.Graphic := nil;
  455.      Temps:='file not found';
  456.      GetMultiBitmap:=Temps;
  457.      Exit;
  458.   end;
  459.  
  460.   If FReadResolution = Color16 then ReadRes := 4;
  461.   If FReadResolution = Color256 then ReadRes := 8;
  462.   If FReadResolution = ColorTrue then ReadRes := 24;
  463.  
  464.   If FDither then
  465.     Dith:=1
  466.   else
  467.     Dith:=0;
  468.  
  469.  If (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
  470.     FreeMsg;
  471.     Picture.LoadFromFile(FFilename);
  472.     Temps:='Non JPeg, BMP, GIF, PNG or PCX Image';
  473.     GetMultiBitmap:=Temps;
  474.     GetInfoAndType(FFilename);
  475.     Exit;
  476.   end;
  477.  
  478.  If Pextension = '.SCM' then begin
  479.     try
  480.      FreeMsg;
  481.      LoadMessageFromFile(FFilename);
  482.     except
  483.      Picture.Graphic := nil;
  484.      OnExcept:=True;
  485.     end;
  486.     If OnExcept then Goto BreakIt;
  487.     GetInfoAndType(FFilename);
  488.  end;
  489.  
  490.  If Pextension = '.CMS' then begin
  491.     try
  492.      FreeMsg;
  493.      LoadCreditMessageFromFile(FFilename);
  494.     except
  495.      Picture.Graphic := nil;
  496.      OnExcept:=True;
  497.     end;
  498.     If OnExcept then Goto BreakIt;
  499.     GetInfoAndType(FFilename);
  500.  end;
  501.  
  502.  If csDesigning in ComponentState then
  503.   If (UpperCase(FFilename) = Temps) and (Picture.Bitmap <> nil) then Goto BreakIt;
  504.  
  505.  If Pextension = '.BMP' then begin
  506.    try
  507.      FreeMsg;
  508.      Bitmap := TBitmap.Create;
  509.      If not bmpfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  510.        MessageDlg('Reading bmp file failed', mtInformation, [mbOk], 0);
  511.     except
  512.      Picture.Graphic := nil;
  513.      Bitmap.Free;
  514.      OnExcept:=True;
  515.     end;
  516.      If OnExcept then Goto BreakIt;
  517.      Picture.Graphic:=Bitmap;
  518.      Bitmap.Free;
  519.      GetInfoAndType(FFilename);
  520.  end;
  521.  
  522.  If Pextension = '.RES' then begin
  523.    try
  524.      FreeMsg;
  525.      Bitmap := TBitmap.Create;
  526.      If not resfile(ResProgName, JustName(FFilename), Handle, Bitmap) then
  527.        MessageDlg('Reading resource file failed', mtInformation, [mbOk], 0);
  528.     except
  529.      Picture.Graphic := nil;
  530.      Bitmap.Free;
  531.      OnExcept:=True;
  532.     end;
  533.      If OnExcept then Goto BreakIt;
  534.      Picture.Graphic:=Bitmap;
  535.      Bitmap.Free;
  536.      GetInfoAndType(FFilename);
  537.  end;
  538.  
  539.  If Pextension = '.PNG' then begin
  540.     try
  541.      FreeMsg;
  542.      Bitmap := TBitmap.Create;
  543.      If not pngfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  544.        MessageDlg('Reading png file failed', mtInformation, [mbOk], 0);
  545.     except
  546.      Picture.Graphic := nil;
  547.      Bitmap.Free;
  548.      OnExcept:=True;
  549.     end;
  550.      If OnExcept then Goto BreakIt;
  551.      Picture.Graphic:=Bitmap;
  552.      Bitmap.Free;
  553.      GetInfoAndType(FFilename);
  554.  end;
  555.  
  556.  If Pextension = '.GIF' then begin
  557.     try
  558.      FreeMsg;
  559.      Bitmap := TBitmap.Create;
  560.      If not Giffile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  561.        MessageDlg('Reading gif file failed', mtInformation, [mbOk], 0);
  562.     except
  563.      Picture.Graphic := nil;
  564.      Bitmap.Free;
  565.      OnExcept:=True;
  566.     end;
  567.      If OnExcept then Goto BreakIt;
  568.      Picture.Graphic:=Bitmap;
  569.      Bitmap.Free;
  570.      GetInfoAndType(FFilename);
  571.  end;
  572.  
  573.  If Pextension = '.PCX' then begin
  574.     try
  575.      FreeMsg;
  576.      Bitmap := TBitmap.Create;
  577.      If not PCXfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  578.        MessageDlg('Reading pcx file failed', mtInformation, [mbOk], 0);
  579.     except
  580.      Picture.Graphic := nil;
  581.      Bitmap.Free;
  582.      OnExcept:=True;
  583.     end;
  584.      If OnExcept then Goto BreakIt;
  585.      Picture.Graphic:=Bitmap;
  586.      Bitmap.Free;
  587.      GetInfoAndType(FFilename);
  588.  end;
  589.  
  590.  If Pextension = '.JPG' then begin
  591.     try
  592.      FreeMsg;
  593.      Bitmap := TBitmap.Create;
  594.      If not jpgfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  595.        MessageDlg('Reading jpg file failed', mtInformation, [mbOk], 0);
  596.     except
  597.      Picture.Graphic := nil;
  598.      Bitmap.Free;
  599.      OnExcept:=True;
  600.     end;
  601.      If OnExcept then Goto BreakIt;
  602.      Picture.Graphic:=Bitmap;
  603.      Bitmap.Free;
  604.      GetInfoAndType(FFilename);
  605.  end;
  606.  
  607.  BreakIt:
  608.  Temps:=UpperCase(FFilename);
  609.  GetMultiBitmap:=Temps;
  610. end;
  611. {------------------------------------------------------------------------}
  612.  
  613. function TPMultiImage.GetSmooth : Byte;
  614. begin
  615.   GetSmooth:=FSaveSmooth;
  616. end;
  617. {------------------------------------------------------------------------}
  618.  
  619. procedure TPMultiImage.SetSmooth(Smooth : Byte);
  620. begin
  621.   If (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  622.    FSaveSmooth:=Smooth;
  623. end;
  624. {------------------------------------------------------------------------}
  625.  
  626. function TPMultiImage.GetQuality : Byte;
  627. begin
  628.   GetQuality:=FSaveQuality;
  629. end;
  630. {------------------------------------------------------------------------}
  631.  
  632. procedure TPMultiImage.SetQuality(Quality : Byte);
  633. begin
  634.   If (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  635.    FSaveQuality:=Quality;
  636. end;
  637. {------------------------------------------------------------------------}
  638.  
  639. function TPMultiImage.GetSaveFilename : TFilename;
  640. begin
  641.   GetSaveFilename:=FSaveFilename;
  642. end;
  643. {------------------------------------------------------------------------}
  644.  
  645. procedure TPMultiImage.SetSaveFilename(fn : TFilename);
  646. begin
  647.  If fn <> '' then
  648.    FSaveFilename:=fn
  649.  else
  650.    FSaveFilename:='';
  651. end;
  652.  
  653.  
  654. {------------------------------------------------------------------------}
  655. procedure TPMultiImage.SaveAsBMP(FN : TFilename);
  656. var
  657.   WriteRes : Integer;
  658. begin
  659.  
  660.   If FWriteResolution = Color16 then WriteRes := 4;
  661.   If FWriteResolution = Color256 then WriteRes := 8;
  662.   If FWriteResolution = ColorTrue then WriteRes := 24;
  663.  
  664.   If fn <> '' then FSaveFilename:=fn;
  665.   try
  666.     If not putbmpfile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
  667.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  668.   except
  669.  
  670.   end;
  671. end;
  672.  
  673. {------------------------------------------------------------------------}
  674.  
  675. procedure TPMultiImage.SaveAsPNG(FN : TFilename);
  676. var
  677.   WriteRes : Integer;
  678.   InterL   : Byte;
  679. begin
  680.   If FWriteResolution = Color16 then WriteRes := 4;
  681.   If FWriteResolution = Color256 then WriteRes := 8;
  682.   If FWriteResolution = ColorTrue then WriteRes := 24;
  683.   If FInterlaced then InterL :=1 else InterL :=0;
  684.  
  685.   If fn <> '' then FSaveFilename:=fn;
  686.  
  687.   try
  688.     If not putpngfile(FSaveFilename, WriteRes, Interl, Picture.Bitmap, TPMultiImageCallBack) then
  689.       MessageDlg('Writing png file failed', mtInformation, [mbOk], 0);
  690.   except
  691.  
  692.   end;
  693. end;
  694.  
  695. {------------------------------------------------------------------------}
  696.  
  697. procedure TPMultiImage.SaveAsJpg(FN : TFilename);
  698. begin
  699.    If fn <> '' then FSaveFilename:=fn;
  700.   try
  701.    If not putjpgfile(FSaveFilename, FSaveQuality, FSaveSmooth, picture.Bitmap, TPMultiImageCallBack) then
  702.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  703.   except
  704.  
  705.   end;
  706. end;
  707. {------------------------------------------------------------------------}
  708.  
  709. procedure TPMultiImage.SaveAsGIF(FN : TFilename);
  710. var
  711.   WriteRes : Integer;
  712. begin
  713.  
  714.   If FWriteResolution = Color16 then WriteRes := 4;
  715.   If FWriteResolution = Color256 then WriteRes := 8;
  716.   If FWriteResolution = ColorTrue then WriteRes := 24;
  717.  
  718.   If fn <> '' then FSaveFilename:=fn;
  719.   try
  720.     If not putgiffile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
  721.       MessageDlg('Writing gif file failed', mtInformation, [mbOk], 0);
  722.   except
  723.  
  724.   end;
  725. end;
  726. {------------------------------------------------------------------------}
  727.  
  728. procedure TPMultiImage.SaveAsPCX(FN : TFilename);
  729. var
  730.   WriteRes : Integer;
  731. begin
  732.  
  733.   If FWriteResolution = Color16 then WriteRes := 4;
  734.   If FWriteResolution = Color256 then WriteRes := 8;
  735.   If FWriteResolution = ColorTrue then WriteRes := 24;
  736.  
  737.   If fn <> '' then FSaveFilename:=fn;
  738.   try
  739.    If not putpcxfile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
  740.       MessageDlg('Writing pcx file failed', mtInformation, [mbOk], 0);
  741.   except
  742.  
  743.   end;
  744. end;
  745. {------------------------------------------------------------------------}
  746.  
  747. function TPMultiImage.GetInfoAndType(Filename : TFilename) : Boolean;
  748. var
  749.   Pextension : String[4];
  750.   F          : file of Byte;
  751.   InfoSize   : Integer;
  752. begin
  753.  Pextension:=UpperCase(ExtractFileExt(Filename));
  754.  
  755.  If (Pextension =  '.RES') then begin
  756.     BFiletype           := 'RES';
  757.     Bwidth              := Picture.width;
  758.     BHeight             := Picture.Height;
  759.     Bbitspixel          := 0;
  760.     Bplanes             := 0;
  761.     Bnumcolors          := 0;
  762.     Bcompression        := 'BMP';
  763.     GetDIBSizes(Picture.BitMap.Handle, InfoSize, Bsize);
  764.     Bsize:=Bsize+InfoSize;
  765.     GetInfoAndType:=True;
  766.     Exit;
  767.   end else
  768.  
  769.  If (Pextension =  '.WMF') or
  770.     (Pextension =  '.ICO') or
  771.     (Pextension =  '.SCM') or
  772.     (Pextension =  '.CMS') then begin
  773.  
  774.   If fileexists(Filename) then begin
  775.     Delete(Pextension,1,1);
  776.     BFiletype           := Pextension;
  777.     Bwidth              := Picture.width;
  778.     BHeight             := Picture.Height;
  779.     Bbitspixel          := 0;
  780.     Bplanes             := 0;
  781.     Bnumcolors          := 0;
  782.     Bcompression        := Pextension;
  783.     AssignFile(f, FFilename);
  784.     Reset(f);
  785.     Bsize := FileSize(f);
  786.     CloseFile(f);
  787.     GetInfoAndType:=True;
  788.     Exit;
  789.   end else
  790.  
  791.   begin
  792.     BFiletype           := 'ERR';
  793.     Bwidth              := -1;
  794.     BHeight             := -1;
  795.     Bbitspixel          := -1;
  796.     Bplanes             := -1;
  797.     Bnumcolors          := -1;
  798.     Bcompression        := 'ERR';
  799.     Bsize               := -1;
  800.     GetInfoAndType      := False;
  801.     Exit;
  802.   end;
  803.  end;
  804.  
  805.   GetInfoAndType:=GetFileInfo(Filename,
  806.                               BFileType,
  807.                               Bwidth,
  808.                               BHeight,
  809.                               Bbitspixel,
  810.                               Bplanes,
  811.                               Bnumcolors,
  812.                               Bcompression);
  813.    AssignFile(f, Filename);
  814.    Reset(f);
  815.    Bsize := FileSize(f);
  816.    CloseFile(f);
  817.  end;
  818. {------------------------------------------------------------------------
  819.  ClipBoard stuff
  820. ------------------------------------------------------------------------}
  821.  
  822. procedure TPMultiImage.WMCut(var Message: TMessage);
  823. begin
  824.   CutToClipboard;
  825. end;
  826. {------------------------------------------------------------------------}
  827.  
  828. procedure TPMultiImage.WMCopy(var Message: TMessage);
  829. begin
  830.   CopyToClipboard;
  831. end;
  832. {------------------------------------------------------------------------}
  833.  
  834. procedure TPMultiImage.WMPaste(var Message: TMessage);
  835. begin
  836.   PasteFromClipboard;
  837. end;
  838. {------------------------------------------------------------------------}
  839.  
  840. procedure TPMultiImage.CopyToClipboard;
  841. begin
  842.   If Picture.Graphic <> nil then Clipboard.Assign(Picture);
  843. end;
  844. {------------------------------------------------------------------------}
  845.  
  846. procedure TPMultiImage.CutToClipboard;
  847. begin
  848.   If Picture.Graphic <> nil then
  849.   begin
  850.     CopyToClipboard;
  851.     Picture.Graphic := nil;
  852.   end;
  853. end;
  854. {------------------------------------------------------------------------}
  855.  
  856. procedure TPMultiImage.PasteFromClipboard;
  857. begin
  858.   If Clipboard.HasFormat(CF_PICTURE) then begin
  859.     MessageRunning:=False;
  860.     CMessageRunning:=False;
  861.     Picture.Assign(Clipboard);
  862.   end;
  863. end;
  864. {------------------------------------------------------------------------}
  865.  
  866. procedure TPMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  867. begin
  868.   inherited KeyDown(Key, Shift);
  869.   case Key of
  870.     VK_INSERT:
  871.       If ssShift in Shift then PasteFromClipBoard else
  872.         If ssCtrl in Shift then CopyToClipBoard;
  873.     VK_DELETE:
  874.       If ssShift in Shift then CutToClipBoard;
  875.   end;
  876. end;
  877. {------------------------------------------------------------------------}
  878.  
  879. procedure TPMultiImage.KeyPress(var Key: Char);
  880. begin
  881.   inherited KeyPress(Key);
  882.   case Key of
  883.     ^X: CutToClipBoard;
  884.     ^C: CopyToClipBoard;
  885.     ^V: PasteFromClipBoard;
  886.   end;
  887. end;
  888. {------------------------------------------------------------------------
  889.  scrolling message stuff
  890. ------------------------------------------------------------------------}
  891.  
  892. procedure TPMultiImage.LoadMessageFromFile(MessageName : TFilename);
  893. var
  894.   Msg      : TLabel;
  895. begin
  896.   Picture.Assign(nil);
  897.   ScreenWd:=Width;
  898.   ScreenHt:=Height;
  899.   Msg := TLabel.Create(Self);
  900.   readmessagefromfile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  901.   Refresh;
  902.   Msg.Parent :=Self;
  903.   Msg.Visible := False;
  904.   Msg.Font := MsgFont;
  905.   Msg.Caption := MsgText;
  906.   BitWidth:=Msg.Width;
  907.   SMessageLeft := ScreenWd;
  908.   SMessageRight := ScreenWd + Msg.Width;
  909.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  910.   BitMsg.Width := Msg.Width;
  911.   BitMsg.Height := Msg.Height;
  912.   OldColor:=Color;
  913.   Color:=MsgBkGrnd;
  914.  
  915.   with BitMsg.Canvas do begin
  916.     Brush.Color := MsgBkGrnd;
  917.     Font := Msg.Font;
  918.     TextOut(0,0,Msg.Caption);
  919.   end;
  920.  
  921.    Msg.Free;
  922.    Msg := nil;
  923.    MessageRunning:=True;
  924. end;
  925. {------------------------------------------------------------------------}
  926.  
  927.  
  928. procedure TPMultiImage.NewMessage;
  929. var
  930.   Msg      : TLabel;
  931. begin
  932.   FreeMsg;
  933.   If MsgText = '' then Exit;
  934.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  935.   ScreenWd:=Width;
  936.   ScreenHt:=Height;
  937.   Msg := TLabel.Create(Self);
  938.   Refresh;
  939.   Msg.Parent :=Self;
  940.   Msg.Visible := False;
  941.   Msg.Font := MsgFont;
  942.   Msg.Caption := MsgText;
  943.   BitWidth:=Msg.Width;
  944.   SMessageLeft := ScreenWd;
  945.   SMessageRight := ScreenWd + Msg.Width;
  946.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  947.   BitMsg.Width := Msg.Width;
  948.   BitMsg.Height := Msg.Height;
  949.   OldColor:=Color;
  950.   Color:=MsgBkGrnd;
  951.  
  952.   with Canvas do begin
  953.     Brush.Style := bsSolid;
  954.     Brush.Color:=MsgBkGrnd;
  955.     Rectangle(0, 0, Width, Height);
  956.   end;
  957.  
  958.   with BitMsg.Canvas do begin
  959.     Brush.Color := MsgBkGrnd;
  960.     Font := Msg.Font;
  961.     TextOut(0,0,Msg.Caption);
  962.   end;
  963.  
  964.    Msg.Free;
  965.    Msg := nil;
  966.    MessageRunning:=True;
  967. end;
  968. {------------------------------------------------------------------------}
  969.  
  970. procedure TPMultiImage.SaveCurrentMessage(MessageName : TFilename);
  971. begin
  972.   WriteMessageToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  973. end;
  974. {------------------------------------------------------------------------}
  975.  
  976. procedure TPMultiImage.CreateMessage(MessagePath : String; AutoLoad : Boolean);
  977. var
  978.  SaveDlg : TSaveDialog;
  979.  MsName  : TFilename;
  980. begin
  981.  SetupMsg30:=TSetupMsg30.Create(Self);
  982.  SetupMsg30.ShowModal;
  983.  MsName:='';
  984.  If SetupMsg30.ModalResult = mrOK then begin
  985.    SaveDlg :=TSaveDialog.Create(self);
  986.    SaveDlg.DefaultExt:='scm';
  987.    SaveDlg.Filter:='scrollmessage|*.scm';
  988.    SaveDlg.Options:=[ofOverwritePrompt];
  989.    SaveDlg.InitialDir:=MessagePath;
  990.    If SaveDlg.Execute then begin
  991.     MsName:=SaveDlg.Filename;
  992.     WriteMessageToFile(MsName,
  993.                        SetupMsg30.MessageFont,
  994.                        SetupMsg30.MessageSpeed,
  995.                        SetupMsg30.MessageColor,
  996.                        SetupMsg30.MessageMsg);
  997.     If (AutoLoad) and (MsName <> '')  then
  998.       LoadMessageFromFile(MsName)
  999.     else
  1000.       NewMessage;
  1001.  
  1002.    end;
  1003.    SaveDlg.free;
  1004.  end;
  1005.  SetupMsg30.destroy;
  1006.  SetupMsg30:=Nil;
  1007. end;
  1008. {------------------------------------------------------------------------}
  1009.  
  1010. Procedure TPMultiImage.FreeMsg;
  1011. Begin
  1012.   If MessageRunning then
  1013.    Color:=OldColor;
  1014.   If CMessageRunning then
  1015.    Color:=OldColor;
  1016.   CMessageRunning:=False;
  1017.   MessageRunning:=False;
  1018.   Picture.Assign(nil);
  1019. end;
  1020. {------------------------------------------------------------------------}
  1021.  
  1022. Function TPMultiImage.Delay(Ms : Integer) : boolean;
  1023. Begin
  1024.  Inc(DelayCounter);
  1025.  If DelayCounter > MS then begin
  1026.     DelayCounter:=0;
  1027.     Result:=True;
  1028.  end else
  1029.   Result:=False;
  1030. end;
  1031. {------------------------------------------------------------------------}
  1032.  
  1033. Procedure TPMultiImage.MoveMsg(Var WinMsg : TMessage);
  1034. Begin
  1035.   If Not MessageRunning then Exit;
  1036.   If not Delay(MsgSpeed) then Exit;
  1037.   Dec(SMessageLeft,1);
  1038.   Dec(SMessageRight,1);
  1039.   If SMessageRight < 0 then begin
  1040.     SMessageLeft := ScreenWd;
  1041.     SMessageRight := SMessageLeft + BitWidth;
  1042.   end;
  1043.     with Canvas do
  1044.        Draw(SMessageLeft,SMessageTop,BitMsg);
  1045. end;
  1046. {------------------------------------------------------------------------}
  1047.  
  1048. Procedure TPMultiImage.Trigger;
  1049. Begin
  1050.   PostMessage(Handle, WM_Trigger, 0, 0);
  1051.   PostMessage(Handle, WM_CTrigger, 0, 0);
  1052.   If visible then begin
  1053.    If SetupMsg30 <> nil then SetupMsg30.Trigger;
  1054.    If SetupCredMsg30 <> nil then SetupCredMsg30.Trigger;
  1055.   end;
  1056. End;
  1057. {------------------------------------------------------------------------
  1058.  credit message stuff
  1059. ------------------------------------------------------------------------}
  1060.  
  1061. procedure TPMultiImage.LoadCreditMessageFromFile(MessageName : TFilename);
  1062. var
  1063.   Msg      : TLabel;
  1064. begin
  1065.   Picture.Assign(nil);
  1066.   ReadCreditFromFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
  1067.   Creditcounter:=0;
  1068.   If CreditBoxList.Count <1 then Exit;
  1069.   MsgText:=CreditBoxList.Strings[Creditcounter];
  1070.  
  1071.   If MsgText = '' then Exit;
  1072.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  1073.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1074.  
  1075.   ScreenWd:=Width;
  1076.   ScreenHt:=Height;
  1077.   Refresh;
  1078.   Msg := TLabel.Create(Self);
  1079.   Refresh;
  1080.   Msg.Parent :=Self;
  1081.   Msg.Visible := False;
  1082.   Msg.Font := MsgFont;
  1083.   Msg.Caption := MsgText;
  1084.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  1085.   BitHeight:=Msg.Height;
  1086.   BitWidth:=Msg.Width;
  1087.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  1088.   SMessageTop := ScreenHt;
  1089.   SMessageBottom := SMessageTop + Msg.Height;
  1090.  
  1091.   BitMsg.Width := Msg.Width;
  1092.   BitMsg.Height := Msg.Height+5;
  1093.   OldColor:=Color;
  1094.   Color:=MsgBkGrnd;
  1095.  
  1096.   with Canvas do begin
  1097.     Brush.Style := bsSolid;
  1098.     Brush.Color:=MsgBkGrnd;
  1099.     Rectangle(0, 0, Width, Height);
  1100.   end;
  1101.  
  1102.   with BitMsg.Canvas do begin
  1103.     Brush.Color := MsgBkGrnd;
  1104.     Pen.Color:=MsgBkGrnd;
  1105.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  1106.     Font := Msg.Font;
  1107.     TextOut(0,0,Msg.Caption);
  1108.   end;
  1109.  
  1110.    Msg.Free;
  1111.    Msg := nil;
  1112.    CMessageRunning:=True;
  1113. end;
  1114. {------------------------------------------------------------------------}
  1115.  
  1116. procedure TPMultiImage.NewCreditMessage;
  1117. var
  1118.   Msg      : TLabel;
  1119. begin
  1120.   If CreditBoxList.Count <1 then Exit;
  1121.   If Creditcounter > CreditBoxList.Count then Creditcounter:=0;
  1122.  
  1123.   MsgText:=CreditBoxList.Strings[Creditcounter];
  1124.   If MsgText = '' then Exit;
  1125.  
  1126.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  1127.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1128.  
  1129.   ScreenWd:=Width;
  1130.   ScreenHt:=Height;
  1131.   Msg := TLabel.Create(Self);
  1132.   Refresh;
  1133.   Msg.Parent :=Self;
  1134.   Msg.Visible := False;
  1135.   Msg.Font := MsgFont;
  1136.   Msg.Caption := MsgText;
  1137.   BitHeight:=Msg.Height;
  1138.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  1139.   BitWidth:=Msg.Width;
  1140.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  1141.   SMessageTop := ScreenHt;
  1142.   SMessageBottom := SMessageTop + Msg.Height;
  1143.   BitMsg.Width := Msg.Width;
  1144.   BitMsg.Height := Msg.Height+5;
  1145.   if not CMessageRunning then
  1146.    OldColor:=Color;
  1147.   Color:=MsgBkGrnd;
  1148.  
  1149.   with Canvas do begin
  1150.     Brush.Style := bsSolid;
  1151.     Brush.Color:=MsgBkGrnd;
  1152.     Rectangle(0, 0, Width, Height);
  1153.   end;
  1154.  
  1155.   with BitMsg.Canvas do begin
  1156.     Brush.Color := MsgBkGrnd;
  1157.     Pen.Color:=MsgBkGrnd;
  1158.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  1159.     Font := Msg.Font;
  1160.     TextOut(0,0,Msg.Caption);
  1161.   end;
  1162.  
  1163.    Msg.Free;
  1164.    Msg := nil;
  1165.    CMessageRunning:=True;
  1166. end;
  1167. {------------------------------------------------------------------------}
  1168.  
  1169. procedure TPMultiImage.SaveCurrentCreditMessage(MessageName : TFilename);
  1170. begin
  1171.   WriteCreditToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
  1172. end;
  1173. {------------------------------------------------------------------------}
  1174.  
  1175. procedure TPMultiImage.CreateCreditMessage(MessagePath : String; AutoLoad : Boolean);
  1176. var
  1177.  SaveDlg : TSaveDialog;
  1178.  MsName  : TFilename;
  1179. begin
  1180.  MsName:='';
  1181.  SetupCredMsg30:=TSetupCredMsg30.Create(Self);
  1182.  SetupCredMsg30.ShowModal;
  1183.  If SetupCredMsg30.ModalResult = mrOK then begin
  1184.    SaveDlg :=TSaveDialog.Create(self);
  1185.    SaveDlg.DefaultExt:='cms';
  1186.    SaveDlg.Filter:='credit message|*.cms';
  1187.    SaveDlg.Options:=[ofOverwritePrompt];
  1188.    SaveDlg.InitialDir:=MessagePath;
  1189.    If SaveDlg.Execute then begin
  1190.     MsName:=SaveDlg.Filename;
  1191.     WriteCreditToFile(MsName,
  1192.                       SetupCredMsg30.MessageFont,
  1193.                       SetupCredMsg30.MessageSpeed,
  1194.                       SetupCredMsg30.MessageColor,
  1195.                       SetupCredMsg30.MessageStrList);
  1196.  
  1197.     If (AutoLoad) and (MsName <> '')  then
  1198.       LoadCreditMessageFromFile(MsName)
  1199.     else
  1200.       NewCreditMessage;
  1201.  
  1202.    end;
  1203.    SaveDlg.free;
  1204.  end;
  1205.  
  1206.  SetupCredMsg30.free;
  1207.  SetupCredMsg30:=Nil;
  1208.  Creditcounter:=0;
  1209. end;
  1210. {------------------------------------------------------------------------}
  1211.  
  1212. Procedure TPMultiImage.MoveCredMsg(Var WinMsg : TMessage);
  1213. Begin
  1214.   If Not CMessageRunning then Exit;
  1215.   If not Delay(MsgSpeed) then Exit;
  1216.   Dec(SMessageTop,1);
  1217.   Dec(SMessageBottom,1);
  1218.   If SMessageTop < (0-BitHeight)-5 then begin
  1219.      If CreditBoxList.Count >0 then begin
  1220.         If Creditcounter < CreditBoxList.Count-1 then
  1221.            Inc(Creditcounter)
  1222.         else Creditcounter:=0;
  1223.         NewCreditMessage;
  1224.      end else begin
  1225.          SMessageTop := ScreenHt;
  1226.          SMessageBottom := SMessageTop + BitHeight;
  1227.      end;
  1228.   end;
  1229.  
  1230.   with Canvas do Draw(SMessageLeft,SMessageTop,BitMsg);
  1231. end;
  1232.  
  1233. {------------------------------------------------------------------------
  1234. Printing Stuff
  1235. ------------------------------------------------------------------------}
  1236.  
  1237. procedure TPMultiImage.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  1238. begin
  1239.  If Picture.Graphic.Empty then Exit;
  1240.  
  1241.  If (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  1242.    PrintICOWMF(X, Y, pWidth, pHeight)
  1243.  else
  1244.    PrintBitmap(X, Y, pWidth, pHeight)
  1245. end;
  1246. {---------------------------------------------------------------------}
  1247.  
  1248. procedure TPMultiImage.PrintBitmap(X, Y, pWidth, pHeight: Integer);
  1249. var
  1250.   Info     : PBitmapInfo;
  1251.   InfoSize : Integer;
  1252.   Image    : Pointer;
  1253.   ImageSize: Longint;
  1254. begin
  1255.    If (pWidth < 1) or (pHeight < 1) then begin
  1256.       pWidth:=Picture.Bitmap.Width;
  1257.       pHeight:=Picture.Bitmap.Height;
  1258.    end;
  1259.  
  1260.    Printer.Begindoc;
  1261.  
  1262.     with Picture.Bitmap do begin
  1263.       GetDIBSizes(Handle, InfoSize, ImageSize);
  1264.       Info := MemAlloc(InfoSize);
  1265.       try
  1266.         Image := MemAlloc(ImageSize);
  1267.         try
  1268.           GetDIB(Handle, Palette, Info^, Image^);
  1269.           with Info^.bmiHeader do
  1270.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  1271.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  1272.             DIB_RGB_COLORS, SRCCOPY)
  1273.          finally
  1274.           FreeMem(Image, ImageSize);
  1275.          end;
  1276.       finally
  1277.        FreeMem(Info, InfoSize);
  1278.       end;
  1279.     end;
  1280.     Printer.Enddoc;
  1281.   end;
  1282. {---------------------------------------------------------------------}
  1283.  
  1284. procedure TPMultiImage.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  1285. begin
  1286.  If (pWidth < 1) or (pHeight < 1) then begin
  1287.     pWidth:=Picture.Graphic.Width;
  1288.     pHeight:=Picture.Graphic.Height;
  1289.  end;
  1290.  Printer.Begindoc;
  1291.  Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  1292.  Printer.Enddoc;
  1293. end;
  1294. {------------------------------------------------------------------------
  1295. end TPMultiImage
  1296. ------------------------------------------------------------------------}
  1297.  
  1298.  
  1299. begin
  1300.  TPMultiImageCallBack:=nil;
  1301. end.
  1302.  
  1303.  
  1304.